home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / cmpnew / cmpmulti.lsp < prev    next >
Lisp/Scheme  |  1987-06-03  |  7KB  |  199 lines
  1. ;;; CMPMULT  Multiple-value-call and Multiple-value-prog1.
  2. ;;;
  3. ;; (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  4. ;; Copying of this file is authorized to users who have executed the true and
  5. ;; proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  6.  
  7. (in-package 'compiler)
  8.  
  9. (si:putprop 'multiple-value-call 'c1multiple-value-call 'c1special)
  10. (si:putprop 'multiple-value-call 'c2multiple-value-call 'c2)
  11. (si:putprop 'multiple-value-prog1 'c1multiple-value-prog1 'c1special)
  12. (si:putprop 'multiple-value-prog1 'c2multiple-value-prog1 'c2)
  13. (si:putprop 'values 'c1values 'c1)
  14. (si:putprop 'values 'c2values 'c2)
  15. (si:putprop 'multiple-value-setq 'c1multiple-value-setq 'c1)
  16. (si:putprop 'multiple-value-setq 'c2multiple-value-setq 'c2)
  17. (si:putprop 'multiple-value-bind 'c1multiple-value-bind 'c1)
  18. (si:putprop 'multiple-value-bind 'c2multiple-value-bind 'c2)
  19.  
  20. (defun c1multiple-value-call (args &aux info funob)
  21.   (when (endp args) (too-few-args 'multiple-value-call 1 0))
  22.   (cond ((endp (cdr args)) (c1funcall args))
  23.         (t (setq funob (c1funob (car args)))
  24.            (setq info (copy-info (cadr funob)))
  25.            (setq args (c1args (cdr args) info))
  26.            (list 'multiple-value-call info funob args)))
  27.   )
  28.  
  29. (defun c2multiple-value-call (funob forms &aux (*vs* *vs*) loc top)
  30.   (cond ((endp (cdr forms))
  31.          (setq loc (save-funob funob))
  32.          (let ((*value-to-go* 'top)) (c2expr* (car forms)))
  33.          (c2funcall funob 'args-pushed loc))
  34.         (t
  35.          (setq top (next-cvar))
  36.          (setq loc (save-funob funob))
  37.          (wt-nl "{object *V" top "=base+" *vs* ";")
  38.          (base-used)
  39.          (dolist** (form forms)
  40.            (let ((*value-to-go* 'top)) (c2expr-top* form top))
  41.            (wt-nl "while(vs_base<vs_top)")
  42.            (wt-nl "{V" top "[0]=vs_base[0];V" top "++;vs_base++;}"))
  43.          (wt-nl "vs_base=base+" *vs* ";vs_top=V" top ";")
  44.          (base-used)
  45.          (c2funcall funob 'args-pushed loc)
  46.          (wt "}")))
  47.   )
  48.  
  49. (defun c1multiple-value-prog1 (args &aux (info (make-info)) form)
  50.   (when (endp args) (too-few-args 'multiple-value-prog1 1 0))
  51.   (setq form (c1expr* (car args) info))
  52.   (setq args (c1args (cdr args) info))
  53.   (list 'multiple-value-prog1 info form args)
  54.   )
  55.  
  56. (defun c2multiple-value-prog1 (form forms &aux (base (next-cvar))
  57.                                                (top (next-cvar)))
  58.   (let ((*value-to-go* 'top)) (c2expr* form))
  59.   (wt-nl "{object *V" top "=vs_top;object *V" base "=vs_base;")
  60.   (dolist** (form forms)
  61.     (let ((*value-to-go* 'trash)) (c2expr-top* form top)))
  62.   (wt-nl "vs_base=V" base ";vs_top=V" top ";}")
  63.   (unwind-exit 'fun-val)
  64.   )
  65.  
  66. (defun c1values (args &aux (info (make-info)))
  67.        (setq args (c1args args info))
  68.        (list 'values info args))
  69.  
  70. (defun c2values (forms &aux (base *vs*) (*vs* *vs*))
  71.   (cond ((null forms)
  72.          (wt-nl "vs_base=vs_top=base+" base ";")
  73.          (base-used)
  74.          (wt-nl "vs_base[0]=Cnil;"))
  75.         (t
  76.          (dolist** (form forms)
  77.            (let ((*value-to-go* (list 'vs (vs-push)))) (c2expr* form)))
  78.          (wt-nl "vs_top=(vs_base=base+" base ")+" (- *vs* base) ";")
  79.          (base-used)))
  80.   (unwind-exit 'fun-val))
  81.  
  82. (defun c1multiple-value-setq (args &aux (info (make-info)) (vrefs nil))
  83.   (when (or (endp args) (endp (cdr args)))
  84.         (too-few-args 'multiple-value-setq 2 0))
  85.   (unless (endp (cddr args))
  86.           (too-many-args 'multiple-value-setq 2 (length args)))
  87.   (dolist (var (car args))
  88.           (cmpck (not (symbolp var)) "The variable ~s is not a symbol." var)
  89.           (cmpck (constantp var)
  90.                  "The constant ~s is being assigned a value." var)
  91.           (setq var (c1vref var))
  92.           (push var vrefs)
  93.           (push (car var) (info-changed-vars info))
  94.           )
  95.   (list 'multiple-value-setq info (reverse vrefs) (c1expr* (cadr args) info))
  96.   )
  97.  
  98. (defun c2multiple-value-setq (vrefs form)
  99.   (let ((*value-to-go* 'top)) (c2expr* form))
  100.   (do ((vs vrefs (cdr vs)))
  101.       ((endp vs))
  102.       (declare (object vs))
  103.       (let ((vref (car vs)))
  104.            (declare (object vref))
  105.            (wt-nl "if(vs_base<vs_top){")
  106.            (set-var 'fun-val (car vref) (cadr vref))
  107.            (unless (endp (cdr vs)) (wt-nl "vs_base++;"))
  108.            (wt-nl "}else{") (set-var nil (car vref) (cadr vref))
  109.            (wt "}"))
  110.       )
  111.   (cond ((null vrefs)
  112.          (wt-nl "if(vs_base=vs_top){vs_base[0]=Cnil;vs_top=vs_base+1;}")
  113.          (unwind-exit 'fun-val))
  114.         (t (unless (eq *exit* 'return) (wt-nl) (reset-top))
  115.            (unwind-exit (cons 'var (car vrefs)))))
  116.   )
  117.  
  118. (defun c1multiple-value-bind (args &aux (info (make-info))
  119.                                    (vars nil) (vnames nil) init-form
  120.                                    ss is ts body other-decls
  121.                                    (*vars* *vars*))
  122.   (when (or (endp args) (endp (cdr args)))
  123.     (too-few-args 'multiple-value-bind 2 (length args)))
  124.  
  125.   (multiple-value-setq (body ss ts is other-decls) (c1body (cddr args) nil))
  126.  
  127.   (c1add-globals ss)
  128.  
  129.   (dolist** (s (car args))
  130.     (let ((v (c1make-var s ss is ts)))
  131.       (push s vnames)
  132.       (push v vars)))
  133.  
  134.   (setq init-form (c1expr* (cadr args) info))
  135.  
  136.   (dolist* (v (reverse vars)) (push v *vars*))
  137.  
  138.   (check-vdecl vnames ts is)
  139.  
  140.   (setq body (c1decl-body other-decls body))
  141.  
  142.   (add-info info (cadr body))
  143.   (setf (info-type info) (info-type (cadr body)))
  144.  
  145.   (dolist** (var vars) (check-vref var))
  146.  
  147.   (list 'multiple-value-bind info (reverse vars) init-form body)
  148.   )
  149.  
  150. (defun c2multiple-value-bind (vars init-form body
  151.                    &aux (block-p nil) (labels nil)
  152.                         (*unwind-exit* *unwind-exit*)
  153.                         (*vs* *vs*) (*clink* *clink*) (*ccb-vs* *ccb-vs*))
  154.        (declare (object block-p))
  155.  
  156.   (dolist** (var vars)
  157.     (let ((kind (c2var-kind var)))
  158.          (declare (object kind))
  159.       (if kind
  160.           (let ((cvar (next-cvar)))
  161.             (setf (var-kind var) kind)
  162.             (setf (var-loc var) cvar)
  163.             (wt-nl)
  164.             (unless block-p (wt "{") (setq block-p t))
  165.             (wt (rep-type kind) "V" cvar ";"))
  166.           (setf (var-ref var) (vs-push)))))
  167.  
  168.   (let ((*value-to-go* 'top)) (c2expr* init-form))
  169.   (let ((*clink* *clink*)
  170.         (*unwind-exit* *unwind-exit*)
  171.         (*ccb-vs* *ccb-vs*))
  172.     (do ((vs vars (cdr vs)))
  173.         ((endp vs))
  174.         (declare (object vs))
  175.       (push (next-label) labels)
  176.       (wt-nl "if(vs_base>=vs_top){")
  177.       (reset-top)
  178.       (wt-go (car labels)) (wt "}")
  179.       (c2bind-loc (car vs) '(vs-base 0))
  180.       (unless (endp (cdr vs)) (wt-nl "vs_base++;"))))
  181.  
  182.   (wt-nl) (reset-top)
  183.  
  184.   (let ((label (next-label)))
  185.     (wt-nl) (wt-go label)
  186.  
  187.     (setq labels (reverse labels))
  188.  
  189.     (dolist** (v vars)
  190.       (wt-label (car labels))
  191.       (pop labels)
  192.       (c2bind-loc v nil))
  193.  
  194.     (wt-label label))
  195.  
  196.   (c2expr body)
  197.   (when block-p (wt "}"))
  198.   )
  199.